home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / printers / print-exps.scm next >
Encoding:
Text File  |  1994-09-27  |  13.5 KB  |  448 lines  |  [TEXT/CCL2]
  1. ;;; print-exps.scm -- print expression AST structures
  2. ;;;
  3. ;;; author :  Sandra Loosemore
  4. ;;; date   :  10 Jan 1992
  5. ;;;
  6. ;;; This file corresponds to ast/exp-structs.scm.
  7. ;;;
  8.  
  9. (define-ast-printer lambda (object xp)
  10.   (with-ast-block (xp)
  11.     (write-string "\\ " xp)
  12.     (write-delimited-list
  13.       (lambda-pats object) xp (function write-apat) "" "" "")
  14.     (write-string " ->" xp)
  15.     (write-whitespace xp)
  16.     (write (lambda-body object) xp)))
  17.  
  18. (define-ast-printer let (object xp)
  19.   (write-lets-body "let " (let-decls object) (let-body object) xp))
  20.  
  21. (define (write-lets-body let-name decls body xp)
  22.   (pprint-logical-block (xp '() "" "")  ; no extra indentation
  23.     (write-string let-name xp)
  24.     (write-layout-rule (remove-recursive-grouping decls) xp (function write))
  25.     (write-whitespace xp)
  26.     (write-string "in " xp)
  27.     (write body xp)))
  28.  
  29. (define-ast-printer if (object xp)
  30.   (with-ast-block (xp)
  31.     (write-string "if " xp)
  32.     (write (if-test-exp object) xp)
  33.     (write-whitespace xp)
  34.     (with-ast-block (xp)
  35.       (write-string "then" xp)
  36.       (write-whitespace xp)
  37.       (write (if-then-exp object) xp))
  38.     (write-whitespace xp)
  39.     (with-ast-block (xp)
  40.       (write-string "else" xp)
  41.       (write-whitespace xp)
  42.       (write (if-else-exp object) xp))))
  43.  
  44. (define-ast-printer case (object xp)
  45.   (with-ast-block (xp)
  46.     (write-string "case " xp)
  47.     (write (case-exp object) xp)
  48.     (write-string " of" xp)
  49.     (write-whitespace xp)
  50.     (write-layout-rule
  51.      (filter (lambda (a) (not (alt-avoid-printing? a))) (case-alts object))
  52.      xp (function write))))
  53.  
  54. (define-ast-printer alt (object xp)
  55.   (with-ast-block (xp)
  56.     (write (alt-pat object) xp)
  57.     (dolist (r (alt-rhs-list object))
  58.       (write-whitespace xp)
  59.       (unless (is-type? 'omitted-guard (guarded-rhs-guard r))
  60.     (write-string "| " xp)
  61.     (write (guarded-rhs-guard r) xp))
  62.       (write-string " -> " xp)
  63.       (write (guarded-rhs-rhs r) xp))
  64.     (write-wheredecls (alt-where-decls object) xp)))
  65.  
  66. (define-ast-printer exp-sign (object xp)
  67.   (with-ast-block (xp)
  68.     (write (exp-sign-exp object) xp)
  69.     (write-string " ::" xp)
  70.     (write-whitespace xp)
  71.     (write (exp-sign-signature object) xp)))
  72.  
  73. (define-ast-printer bottom (object xp)
  74.   (declare (ignore object))
  75.   (write-string "_" xp))
  76.  
  77. ;;; Have to look for application of special-case constructors before
  78. ;;; doing the normal prefix/infix cases.
  79.  
  80. (define-ast-printer app (object xp)
  81.   (let* ((fn          (app-fn object))
  82.      (arg         (app-arg object)))
  83.     (multiple-value-bind (con args) (extract-constructor fn (list arg))
  84.       (cond ;; ((eq? con (core-symbol "UnitConstructor"))
  85.         ;;  *** Does this ever happen?
  86.         ;;  (write-string "()" xp))
  87.         ((and con (is-tuple-constructor? con))
  88.          (write-commaized-list args xp))
  89.         (else
  90.          (multiple-value-bind (fixity op arg1) (extract-infix-operator fn)
  91.            (if fixity
  92.            (write-infix-application fixity op arg1 arg xp)
  93.            (write-prefix-application fn arg xp))))
  94.         ))))
  95.  
  96.  
  97. (define (write-infix-application fixity op arg1 arg2 xp)
  98.   (let ((precedence      (fixity-precedence fixity))
  99.     (associativity   (fixity-associativity fixity)))
  100.     (with-ast-block (xp)
  101.       (write-exp-with-precedence
  102.         arg1 (1+ precedence) (if (eq? associativity 'l) 'l '#f) xp)
  103.       (write-whitespace xp)
  104.       (write op xp)
  105.       (write-whitespace xp)
  106.       (write-exp-with-precedence
  107.         arg2 (1+ precedence) (if (eq? associativity 'r) 'r '#f) xp))))
  108.  
  109. (define (write-prefix-application fn arg xp)      
  110.   (with-ast-block (xp)
  111.     (write-exp-with-precedence fn 10 '#f xp)
  112.     (write-whitespace xp)
  113.     (write-aexp arg xp)))
  114.  
  115.  
  116. ;;; Write an expression with at least the given precedence.  If the
  117. ;;; actual precedence is lower, put parens around it.
  118.  
  119. (define *print-exp-parens* '#f)
  120.  
  121. (define (write-exp-with-precedence exp precedence associativity xp)
  122.   (if *print-exp-parens*
  123.       (write-aexp exp xp)
  124.       (if (< (precedence-of-exp exp associativity) precedence)
  125.       (begin
  126.         (write-char #\( xp)
  127.         (write exp xp)
  128.         (write-char #\) xp))
  129.       (write exp xp))))
  130.  
  131.  
  132. ;;; Similar to the above: write an aexp.
  133.  
  134. (define *print-original-code* '#t)
  135.  
  136. (define (write-aexp object xp)
  137.   (if (is-type? 'save-old-exp object)
  138.       (write-aexp (if *print-original-code*
  139.               (save-old-exp-old-exp object)
  140.               (save-old-exp-new-exp object))
  141.           xp)
  142.       (if (or (is-type? 'aexp object)
  143.           (pp-exp-list-section? object)
  144.           (is-type? 'negate object))
  145.       (write object xp)
  146.       (begin
  147.         (write-char #\( xp)
  148.         (write object xp)
  149.         (write-char #\) xp)))))
  150.  
  151.  
  152. ;;; The infix? slot on var-ref and con-ref structs refers to whether
  153. ;;; the thing appears as an infix operator or not, not whether the name
  154. ;;; has operator or identifier syntax.
  155.  
  156. (define-ast-printer var-ref (object xp)
  157.   (let ((name  (var-ref-name object)))
  158.     (if (var-ref-infix? object)
  159.     (write-varop name xp)
  160.     (write-varid name xp))))
  161.  
  162. (define-ast-printer con-ref (object xp)
  163.   (if (eq? (con-ref-con object) (core-symbol "UnitConstructor"))
  164.       (write-string "()" xp)
  165.       (let ((name  (con-ref-name object)))
  166.     (if (con-ref-infix? object)
  167.         (write-conop name xp)
  168.         (write-conid name xp)))))
  169.  
  170.  
  171. (define-ast-printer integer-const (object xp)
  172.   (write (integer-const-value object) xp))
  173.  
  174. (define-ast-printer float-const (object xp)
  175.   (let* ((numerator   (float-const-numerator object))
  176.      (denominator (float-const-denominator object))
  177.      (exponent    (float-const-exponent object))
  178.      (whole       (quotient numerator denominator))
  179.      (fraction    (remainder numerator denominator)))
  180.     (write whole xp)
  181.     (write-char #\. xp)
  182.     (write-precision-integer fraction denominator xp)
  183.     (unless (zero? exponent)
  184.       (write-char #\E xp)
  185.       (write exponent xp))))
  186.  
  187. (define (write-precision-integer fraction denominator xp)
  188.   (cond ((eqv? denominator 1)
  189.      ; no fraction
  190.      )
  191.     ((eqv? denominator 10)
  192.      (write-digit fraction xp))
  193.     (else
  194.      (write-digit (quotient fraction 10) xp)
  195.      (write-precision-integer (remainder fraction 10)
  196.                   (quotient denominator 10)
  197.                   xp))
  198.     ))
  199.  
  200. (define (write-digit n xp)
  201.   (write-char (string-ref "0123456789" n) xp))
  202.  
  203.  
  204. ;;; Character and string printers need to handle weird escapes.
  205. ;;; Fortunately we can just choose one canonical style for printing
  206. ;;; unprintable characters.
  207.  
  208. (define-ast-printer char-const (object xp)
  209.   (write-char #\' xp)
  210.   (write-char-literal (char-const-value object) xp #\')
  211.   (write-char #\' xp))
  212.  
  213. (define-ast-printer string-const (object xp)
  214.   (write-char #\" xp)
  215.   (let ((s  (string-const-value object)))
  216.     (dotimes (i (string-length s))
  217.       (write-char-literal (string-ref s i) xp #\")))
  218.   (write-char #\" xp))
  219.  
  220. (define (write-char-literal c xp special)
  221.   (cond ((eqv? c special)
  222.      (write-char #\\ xp)
  223.      (write c xp))
  224.     ((eqv? c #\newline)
  225.      (write-char #\\ xp)
  226.      (write-char #\n xp))
  227.     (else
  228.      (let ((code  (char->integer c)))
  229.        (if (and (>= code 32) (< code 128))
  230.            ;; printing ascii characters
  231.            (write-char c xp)
  232.            ;; "control" characters print in \ddd notation
  233.            (begin
  234.          (write-char #\\ xp)
  235.          (write code xp)))))
  236.     ))
  237.  
  238. (define-ast-printer list-exp (object xp)
  239.   (write-delimited-list
  240.     (list-exp-exps object) xp (function write) "," "[" "]"))
  241.  
  242. (define-ast-printer sequence (object xp)
  243.   (with-ast-block (xp)
  244.     (write-string "[" xp)
  245.     (write (sequence-from object) xp)
  246.     (write-string "..]" xp)))
  247.  
  248. (define-ast-printer sequence-to (object xp)
  249.   (with-ast-block (xp)
  250.     (write-string "[" xp)
  251.     (write (sequence-to-from object) xp)
  252.     (write-string " .." xp)
  253.     (write-whitespace xp)
  254.     (write (sequence-to-to object) xp)
  255.     (write-string "]" xp)))
  256.  
  257. (define-ast-printer sequence-then (object xp)
  258.   (with-ast-block (xp)
  259.     (write-string "[" xp)            
  260.     (write (sequence-then-from object) xp)
  261.     (write-string "," xp)
  262.     (write-whitespace xp)
  263.     (write (sequence-then-then object) xp)
  264.     (write-string "..]" xp)))
  265.  
  266. (define-ast-printer sequence-then-to (object xp)
  267.   (with-ast-block (xp)
  268.     (write-string "[" xp)
  269.     (write (sequence-then-to-from object) xp)
  270.     (write-string "," xp)
  271.     (write-whitespace xp)
  272.     (write (sequence-then-to-then object) xp)
  273.     (write-string " .." xp)
  274.     (write-whitespace xp)
  275.     (write (sequence-then-to-to object) xp)
  276.     (write-string "]" xp)))
  277.  
  278. (define-ast-printer list-comp (object xp)
  279.   (with-ast-block (xp)
  280.     (write-string "[" xp)
  281.     (write (list-comp-exp object) xp)
  282.     (write-string " |" xp)
  283.     (write-whitespace xp)
  284.     (write-delimited-list
  285.       (list-comp-quals object) xp (function write) "," "" "")
  286.     (write-string "]" xp)))
  287.  
  288.  
  289. (define-ast-printer section-l (object xp)
  290.   (let* ((exp           (section-l-exp object))
  291.      (op            (section-l-op object))
  292.      (fixity        (operator-fixity op))
  293.      (precedence    (fixity-precedence fixity)))
  294.     (with-ast-block (xp)
  295.       (write-string "(" xp)
  296.       (write op xp)
  297.       (write-whitespace xp)
  298.       (write-exp-with-precedence exp (1+ precedence) '#f xp)
  299.       (write-string ")" xp))))
  300.  
  301. (define-ast-printer section-r (object xp)
  302.   (let* ((exp           (section-r-exp object))
  303.      (op            (section-r-op object))
  304.      (fixity        (operator-fixity op))
  305.      (precedence    (fixity-precedence fixity)))
  306.     (with-ast-block (xp)
  307.       (write-string "(" xp)
  308.       (write-exp-with-precedence exp (1+ precedence) '#f xp)
  309.       (write-whitespace xp)
  310.       (write op xp)
  311.       (write-string ")" xp))))
  312.  
  313. (define-ast-printer qual-generator (object xp)
  314.   (with-ast-block (xp)
  315.     (write (qual-generator-pat object) xp)
  316.     (write-string " <-" xp)
  317.     (write-whitespace xp)
  318.     (write (qual-generator-exp object) xp)))
  319.  
  320. (define-ast-printer qual-filter (object xp)
  321.   (write (qual-filter-exp object) xp))
  322.  
  323.  
  324. ;;; A pp-exp-list with an op as the first or last element is really
  325. ;;; a section.  These always get parens and are treated like aexps.
  326. ;;; Other pp-exp-lists are treated as exps with precedence 0.
  327. ;;; Bleah...  Seems like the parser ought to recognize this up front....
  328. ;;;                                                     Yeah but I'm lazy ...
  329.  
  330. (define-ast-printer pp-exp-list (object xp)
  331.   (let ((section?  (pp-exp-list-section? object)))
  332.     (if section? (write-char #\( xp))
  333.     (write-delimited-list
  334.       (pp-exp-list-exps object) xp (function write-aexp) "" "" "")
  335.     (if section? (write-char #\) xp))))
  336.  
  337. (define-ast-printer negate (object xp)
  338.   (declare (ignore object))
  339.   (write-string "-" xp))
  340.  
  341. (define-ast-printer def (object xp)
  342.   (write-string (symbol->string (def-name object)) xp))
  343.  
  344. (define-ast-printer con (object xp)
  345.   (write-string (remove-con-prefix (symbol->string (def-name object))) xp))
  346.  
  347. (define-ast-printer con-number (object xp)
  348.   (with-ast-block (xp)
  349.     (write-string "con-number/" xp)
  350.     (write (con-number-type object) xp)
  351.     (write-whitespace xp)
  352.     (write-aexp (con-number-value object) xp)))
  353.  
  354. (define-ast-printer sel (object xp)
  355.   (with-ast-block (xp)
  356.     (write-string "sel/" xp)
  357.     (write (sel-constructor object) xp)
  358.     (write-whitespace xp)
  359.     (write (sel-slot object) xp)
  360.     (write-whitespace xp)
  361.     (write-aexp (sel-value object) xp)))
  362.  
  363. (define-ast-printer is-constructor (object xp)
  364. (with-ast-block (xp)
  365.     (write-string "is-constructor/" xp)
  366.     (write (is-constructor-constructor object) xp)
  367.     (write-whitespace xp)
  368.     (write-aexp (is-constructor-value object) xp)))
  369.   
  370. (define-ast-printer void (object xp)
  371.   (declare (ignore object))
  372.   (write-string "Void" xp))
  373.  
  374. (define-ast-printer cast (object xp)
  375.   (with-ast-block (xp)
  376.     (write-string "cast " xp)
  377.     (write-whitespace xp)
  378.     (write-aexp (cast-exp object) xp)))
  379.  
  380. ;;; Special cfn constructs
  381.  
  382. (define-ast-printer case-block (object xp)
  383.   (with-ast-block (xp)
  384.     (write-string "case-block " xp)
  385.     (write (case-block-block-name object) xp)
  386.     (write-whitespace xp)
  387.     (write-layout-rule (case-block-exps object) xp (function write))))
  388.  
  389. (define-ast-printer return-from (object xp)
  390.   (with-ast-block (xp)
  391.     (write-string "return-from " xp)
  392.     (write (return-from-block-name object) xp)
  393.     (write-whitespace xp)
  394.     (write (return-from-exp object) xp)))
  395.  
  396. (define-ast-printer and-exp (object xp)
  397.   (with-ast-block (xp)
  398.     (write-string "and " xp)
  399.     (write-layout-rule (and-exp-exps object) xp (function write))))
  400.  
  401. ;;; Expression types used by the type checker.
  402.  
  403. (define-ast-printer dict-placeholder (object xp)
  404.   (cond ((not (eq? (dict-placeholder-exp object) '#f))
  405.      (write (dict-placeholder-exp object) xp))
  406.     (else
  407.      (write-string "%" xp)
  408.      (write-string (symbol->string
  409.             (def-name (dict-placeholder-class object))) xp))))
  410.  
  411. (define-ast-printer recursive-placeholder (object xp)
  412.   (cond ((not (eq? (recursive-placeholder-exp object) '#f))
  413.      (write (recursive-placeholder-exp object) xp))
  414.     (else
  415.      (write-varid (def-name (recursive-placeholder-var object)) xp))))
  416.  
  417. (define-ast-printer dtype-placeholder (object xp)
  418.   (cond ((not (eq? (dtype-placeholder-exp object) '#f))
  419.      (write (dtype-placeholder-exp object) xp))
  420.     (else
  421.      (write-string " # " xp))))
  422.  
  423. ;;; This should probably have a flag to allow the dictionary converted code
  424. ;;; to be printed during debugging.
  425.  
  426. (define-ast-printer save-old-exp (object xp)
  427.   (write (save-old-exp-old-exp object) xp))
  428.  
  429. ;;; Annotations
  430.  
  431. (define-ast-printer annotation-decl (object xp)
  432.   (write-delimited-list (annotation-decl-names object)
  433.             xp (function write) "," "" " :: ")
  434.   (write-delimited-list (annotation-decl-annotations object)
  435.             xp (function write) "," "" ""))
  436.  
  437. (define-ast-printer annotation-value (object xp)
  438.   (write (annotation-value-name object) xp)
  439.   (when (annotation-value-args object)
  440.     (write-commaized-list (annotation-value-args object) xp)))
  441.  
  442. (define-ast-printer annotation-decls (object xp)
  443.   (write-string "{-#" xp)
  444.   (write-whitespace xp)
  445.   (write-layout-rule (annotation-decls-annotations object) xp (function write))
  446.   (write-string " #-}" xp))
  447.  
  448.